- meaning & definition

AmpersandTarski · Jun 17, 2024 · bd32036 · bd32036
1 parent de22bec
commit bd32036
Show file tree

Hide file tree

Showing 2 changed files with 27 additions and 20 deletions.
diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Ampersand.ADL1.PrettyPrinters (Pretty (..), prettyPrint) where
@@ -110,10 +111,13 @@ instance Pretty P_Context where
         <~> lang
         <~> markup
         <+\> perline metas
+        <+\> text "-- Concepts"
         <+\> perline cs
         <+\> perline reprs
         <+\> perline gs
+        <+\> text "-- Relations"
         <+\> perlineRelations ds
+        <+\> text "-- Rules"
         <+\> perline rs
         <+\> perline enfs
         <+\> perline ks
@@ -149,10 +153,13 @@ instance Pretty P_Pattern where
   pretty (P_Pat _ nm rs gs rels rruls cpts reprs ids vds xps pop _ enfs) =
     text "PATTERN"
       <+> quoteConcept nm
+        <+\> text "-- Concepts"
         <+\> perline cpts
         <+\> perline reprs
         <+\> perline gs
+        <+\> text "-- Relations"
         <+\> perline rels
+        <+\> text "-- Rules"
         <+\> perline rs
         <+\> perline enfs
         <+\> perline ids
@@ -167,7 +174,8 @@ instance Pretty P_Relation where
     text "RELATION"
       <+> (text . T.unpack) nm
         <~> sign
-        <~> props -- altered
+        <~> props
+        <+\> perline mean -- <~> mean heir weggehaald
       <+> if null dflts
         then empty
         else
@@ -178,7 +186,7 @@ instance Pretty P_Relation where
     where
       props
         | null prps = empty
-        | otherwise = pretty $ Set.toList prps
+        | otherwise = pretty $ Set.toList prps -- todo: om props te fixen
 
 instance Pretty Pragma where
   pretty (Pragma _ l m r) = text "PRAGMA" <+> hsep (map quote [l, m, r])
@@ -278,14 +286,13 @@ instance Pretty PConceptDef where
     =
     text "CONCEPT"
       <+> quoteConcept cpt
-      <+> pretty def
-      <+> prettyhsep _mean
+        <~> pretty def -- <+> pretty _mean -- mean weggehaald omdat deze geen functie heeft in het concept (daar is def al voor)
 
 instance Pretty PCDDef where
   pretty (PCDDefNew def) =
     let prettyNoMeaning (PMeaning markup) = pretty markup -- Local function to adjust printing
      in prettyNoMeaning def -- Use the local function for pretty printing
-  pretty (PCDDefLegacy def ref) = quote def <+> maybeText ("[" <> ref <> "]")
+  pretty (PCDDefLegacy def ref) = quote def <+> maybeText ("" <> ref <> "") -- NET GEDAAN ("[" <> ref <> "]")
     where
       maybeText txt =
         if T.null txt
@@ -441,6 +448,7 @@ instance Pretty PMessage where
   pretty (PMessage markup) = text "MESSAGE" <~> markup
 
 instance Pretty P_Concept where
+  pretty :: P_Concept -> Doc
   pretty (PCpt nm) = quoteConcept nm
   pretty P_ONE = text "ONE"
 
@@ -463,7 +471,7 @@ instance Pretty Lang where
 
 instance Pretty P_Markup where
   pretty (P_Markup lang format str) =
-    pretty lang <~> format <+\> quoteMeaning str
+    pretty lang <~> format <+> quoteMeaning str
 
 instance Pretty PandocFormat where
   pretty = text . map toUpper . show

diff --git a/src/Ampersand/Commands/AtlasImport.hs b/src/Ampersand/Commands/AtlasImport.hs
@@ -62,6 +62,7 @@ import Ampersand.Types.Config
 import qualified Data.Aeson as JSON
 import Data.Aeson.Key (fromText)
 import qualified Data.Aeson.Types as JSON
+import qualified RIO
 import qualified RIO.ByteString.Lazy as B
 import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
@@ -221,22 +222,20 @@ instance JSON.FromJSON PConceptDef where
 
 instance JSON.FromJSON PCDDef where
   parseJSON val = case val of
-    JSON.Object v ->
-      -- if object
-      build <$> v JSON..: "definition"
-    JSON.String s ->
-      -- if string
-      pure $ PCDDefNew (PMeaning $ P_Markup Nothing Nothing s)
-    JSON.Array _arr ->
-      -- if array
-      pure $ PCDDefNew (PMeaning $ P_Markup Nothing Nothing "definition not working")
-    invalid ->
-      JSON.prependFailure
-        "parsing PCDDef failed, "
-        (JSON.typeMismatch "Object" invalid)
+    JSON.Object v -> build <$> v JSON..: "definition"
+    JSON.String s -> pure $ PCDDefNew (PMeaning $ P_Markup Nothing Nothing s)
+    JSON.Array arr -> case parseArrayToText arr of
+      Just txt -> pure $ PCDDefNew (PMeaning $ P_Markup Nothing Nothing txt)
+      Nothing -> pure $ PCDDefNew (PMeaning $ P_Markup Nothing Nothing "Definition not provided")
+    invalid -> JSON.prependFailure "parsing PCDDef failed, " (JSON.typeMismatch "Object or String" invalid)
     where
       build :: Text -> PCDDef
-      build def = PCDDefNew (PMeaning $ P_Markup Nothing Nothing def) -- Here we construct PCDDefNew
+      build def = PCDDefNew (PMeaning $ P_Markup Nothing Nothing def)
+
+      parseArrayToText :: RIO.Vector JSON.Value -> Maybe Text
+      parseArrayToText arr = case listToMaybe (toList arr) of
+        Just (JSON.String txt) -> Just txt
+        _ -> Nothing
 
 instance JSON.FromJSON P_Concept where
   parseJSON :: JSON.Value -> JSON.Parser P_Concept