Move to trace system, compiling OK

harris-chris · Nov 26, 2023 · 9a2e613 · 9a2e613
1 parent d1f91b1
commit 9a2e613
Show file tree

Hide file tree

Showing 24 changed files with 255 additions and 207 deletions.
diff --git a/app/ArgValidation.hs b/app/ArgValidation.hs
@@ -6,8 +6,6 @@ module ArgValidation
 
 import qualified Data.Text as T
 
-import Exp
-
 data ArgValidation =
     IsEPar
     | IsEApplyFlat

diff --git a/app/ExceptionFuncs.hs b/app/ExceptionFuncs.hs
@@ -7,37 +7,36 @@ module ExceptionFuncs
 
 import qualified Data.ByteString.Lazy.Char8 as BS
 import Control.Exception
-
-import ArgValidation
 import Data.Text as T
 import TextShow
 
+import ArgValidation
 import Exceptions
-import Exp
-import Reproduces
+import IsTrace
 import Resolved
 import ResolvedFuncs
 
-errorMessageFromFilterStr :: (Reproduces a) => BS.ByteString -> FilterException a -> Builder
+errorMessageFromFilterStr :: IsTrace trc =>
+    BS.ByteString -> FilterException trc -> Builder
 errorMessageFromFilterStr origTxt raw@(Can'tResolveAsBool rep _ _) =
     (showb raw) <> " in "
-    <> (fromText $ reproduce rep $ T.pack $ BS.unpack origTxt)
+    <> (trace (T.pack $ BS.unpack origTxt) rep)
 errorMessageFromFilterStr origTxt raw@(DuplicateName rep _) =
     (showb raw) <> " in "
-    <> (fromText $ reproduce rep $ T.pack $ BS.unpack origTxt)
+    <> (trace (T.pack $ BS.unpack origTxt) rep)
 errorMessageFromFilterStr origTxt raw@(FuncArgWrongType rep _ _ _ _) =
     (showb raw) <> " in "
-    <> (fromText $ reproduce rep $ T.pack $ BS.unpack origTxt)
+    <> (trace (T.pack $ BS.unpack origTxt) rep)
 errorMessageFromFilterStr origTxt raw@(FuncNameNotRecognized rep _) =
     (showb raw) <> " in "
-    <> (fromText $ reproduce rep $ T.pack $ BS.unpack origTxt)
+    <> (trace (T.pack $ BS.unpack origTxt) rep)
 errorMessageFromFilterStr origTxt raw@(FuncWrongNumArgs rep _ _ _) =
     (showb raw) <> " in "
-    <> (fromText $ reproduce rep $ T.pack $ BS.unpack origTxt)
+    <> (trace (T.pack $ BS.unpack origTxt) rep)
 errorMessageFromFilterStr _ raw = showb raw
 
-
-toErrorMessage :: (Reproduces a) => BS.ByteString -> TSException a -> Builder
+toErrorMessage :: IsTrace trc =>
+    BS.ByteString -> TSException trc -> Builder
 toErrorMessage filterStr (Filter filterExc) = errorMessageFromFilterStr filterStr filterExc
 toErrorMessage _ (Other otherExc) = showb otherExc
 
diff --git a/app/Exceptions.hs b/app/Exceptions.hs
@@ -12,14 +12,13 @@ import Control.Exception
 import Data.Text as T
 import Data.Text.Lazy (toStrict)
 import Data.Typeable
+import TextShow
 
-import Exp
 import ResolvedType
-import TextShow
 
 type EitherF a result = Either (FilterException a) result
 
--- TODO: give this 'a' parameters for all constructors, implement HasTrace, and use that in
+-- TODO: give this 'a' parameters for all constructors, implement IsTrace, and use that in
 -- toErrorMessage
 data FilterException a =
     Can'tResolveAsBool a Text ResolvedType

diff --git a/app/Exp.hs b/app/Exp.hs
diff --git a/app/ExpFuncs.hs b/app/ExpFuncs.hs
@@ -12,7 +12,7 @@ import qualified Data.Text as T
 import ArgValidation
 import Exceptions
 import Exp
-import HasTrace
+import IsTrace
 import qualified Lit as LT
 import RawExp
 import RawExpFuncs

diff --git a/app/FunctionDefinition.hs b/app/FunctionDefinition.hs
@@ -8,12 +8,13 @@ import qualified Data.Text as T
 
 import Exceptions
 import FData
+import IsTrace
 
-data FunctionDefinition typeDef exprDef traceType =
+data FunctionDefinition typeDef exprDef trc =
     FunctionDefinition {
         funcName :: T.Text
         , expectedTypes :: [typeDef]
-        , funcApply :: (Semigroup traceType, Show traceType) => FData -> [exprDef traceType] -> EitherF traceType (exprDef traceType)
+        , funcApply :: IsTrace trc => FData -> [exprDef trc] -> EitherF trc (exprDef trc)
     }
 
 instance Eq (FunctionDefinition a b c) where

diff --git a/app/FunctionType.hs b/app/FunctionType.hs
@@ -11,7 +11,6 @@ import qualified Data.List as L
 import TextShow.Debug.Trace
 
 import ArgValidation
-import Exp
 import FunctionDefinition
 import FData
 import RawExp

diff --git a/app/Functions.hs b/app/Functions.hs
@@ -9,7 +9,7 @@ module Functions
 import qualified Data.Text as T
 
 import FData
-import HasTrace
+import IsTrace
 import Lit
 import Resolved
 import ResolvedFuncs
@@ -40,72 +40,73 @@ functions = [
         , FunctionDefinition "map" [TPartiallyApplied [TGeneric "X"], TList (TGeneric "X")] mapFunc
     ]
 
-orFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+orFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 orFunc _ [RLit a (LBool False), RLit _ (LBool False)] = Right $ RLit a $ LBool False
 orFunc _ [RLit a (LBool _), RLit _ (LBool _)] = Right $ RLit a $ LBool True
 
-andFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+andFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 andFunc _ [RLit a (LBool True), RLit _ (LBool True)] = Right $ RLit a $ LBool True
 andFunc _ [RLit a (LBool _), RLit _ (LBool _)] = Right $ RLit a $ LBool False
 
-eqsFunc :: (Semigroup a, Show a) => FData -> [Resolved a] -> EitherF a (Resolved a)
-eqsFunc _ [x, y] = Right $ RLit (getTrace x) $ LBool (x == y)
+eqsFunc :: IsTrace trc => (IsTrace trc) => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
+eqsFunc _ [x, y] = Right $ RLit (getRange x) $ LBool (x == y)
 
-plusFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+plusFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 plusFunc _ [RLit a (LInteger x), RLit _ (LInteger y)] =
     Right $ RLit a $ LInteger $ x + y
 
-minusFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+minusFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 minusFunc _ [RLit a (LInteger x), RLit _ (LInteger y)] =
     Right $ RLit a $ LInteger $ x - y
 
-inFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+inFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 inFunc _ [x, RList a xs] =
     Right $ RLit a $ LBool $ elem x xs
 
-notFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+notFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 notFunc _ [RLit a (LBool True)] = Right $ RLit a $ LBool False
 notFunc _ [RLit a (LBool False)] = Right $ RLit a $ LBool True
 
-basenameFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+basenameFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 basenameFunc fData [RFile a] =
     Right $ RLit a $ LString $ basename fData
 
-isFileFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+isFileFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 isFileFunc fData [RFile a] =
     Right $ RLit a $ LBool $ (fileType fData) == FileFileType
 
-isDirFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+isDirFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 isDirFunc fData [RFile a] =
     Right $ RLit a $ LBool $ (fileType fData) == DirFileType
 
-parentsFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+parentsFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 parentsFunc fData [RFile a] =
     Right $ RList a $ ((RLit a) . LString) <$> (parents fData)
 
-startsWithFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+startsWithFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 startsWithFunc _ [RLit a (LString searchStr), RLit _ (LString str)] =
     Right $ RLit a $ LBool $ T.isPrefixOf searchStr str
 
-endsWithFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+endsWithFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 endsWithFunc _ [RLit a (LString searchStr), RLit _ (LString str)] =
     Right $ RLit a $ LBool $ T.isSuffixOf searchStr str
 
-occursInFunc :: Show a => FData -> [Resolved a] -> EitherF a (Resolved a)
+occursInFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 occursInFunc _ [RLit a (LString searchStr), RLit _ (LString str)] =
     Right $ RLit a $ LBool $ T.isInfixOf searchStr str
 
-mapFunc :: (Show a, Semigroup a) => FData -> [Resolved a] -> EitherF a (Resolved a)
+mapFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 mapFunc fData [f@(RPartiallyApplied _ _ _), RList a xs] =
     let mapped = mapM (\x -> tryToResolvePartial fData f [x]) xs
     in RList a <$> mapped
 
-allFunc :: (Show a, Semigroup a) => FData -> [Resolved a] -> EitherF a (Resolved a)
+allFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 allFunc fData [f@(RPartiallyApplied _ _ _), RList a xs] =
     let asBools = mapM (\x -> convertToBool =<< tryToResolvePartial fData f [x]) xs
     in (\xs' -> RLit a $ LBool $ all id xs') <$> asBools
 
-anyFunc :: (Semigroup a, Show a) => FData -> [Resolved a] -> EitherF a (Resolved a)
+anyFunc :: IsTrace trc => FData -> [Resolved trc] -> EitherF trc (Resolved trc)
 anyFunc fData [f@(RPartiallyApplied _ _ _), RList a xs] =
     let asBools = mapM (\x -> convertToBool =<< tryToResolvePartial fData f [x]) xs
     in (\xs' -> RLit a $ LBool $ any id xs') <$> asBools
+
diff --git a/app/HasTrace.hs b/app/HasTrace.hs
diff --git a/app/Reproduces.hs → app/IsTrace.hs b/app/Reproduces.hs → app/IsTrace.hs
@@ -1,19 +1,17 @@
-module Reproduces (
-    Reproduces
-    , reproduce
+module IsTrace (
+    IsTrace(..)
     , reproduceFromLineCol
 ) where
 
-import qualified Data.ByteString.Lazy.Char8 as BS
 import qualified Data.List as L
-import Data.Maybe
 import qualified Data.Text as T
+import TextShow
 
-class Reproduces a where
-    reproduce :: a -> T.Text -> T.Text
+class (Semigroup a) => IsTrace a where
+    trace :: Semigroup a => T.Text -> a -> Builder
 
-reproduceFromLineCol :: (Int, Int) -> (Int, Int) -> T.Text -> T.Text
-reproduceFromLineCol (lineX, colX) (lineY, colY) origTxt =
+reproduceFromLineCol :: T.Text -> (Int, Int) -> (Int, Int) -> Builder
+reproduceFromLineCol origTxt (lineX, colX) (lineY, colY) =
     let asLines = T.lines origTxt
         lines = take (lineY - lineX + 1) $ drop (lineX - 1) asLines
         lines' = case lines of
@@ -28,5 +26,5 @@ reproduceFromLineCol (lineX, colX) (lineY, colY) origTxt =
                               firstLine' = T.drop colY firstLine
                               lastLine' = T.take colY lastLine
                           in firstLine':(midLines ++ [lastLine'])
-    in T.unlines lines'
+    in fromText $ T.unlines lines'
 
diff --git a/app/Lexer.x b/app/Lexer.x
@@ -23,7 +23,7 @@ import qualified Data.Text as T
 import Data.ByteString.Lazy.Char8 (ByteString, length, lines)
 import Data.Text.Encoding
 
-import Reproduces
+import IsTrace
 
 }
 -- In the middle, we insert our definitions for the lexer, which will generate the lexemes for our grammar.
@@ -86,16 +86,16 @@ getFullRange filterStr =
         stop' = AlexPn 0 (L.length strLines) (fromIntegral $ length $ last strLines)
     in Range start' stop'
 
-instance Reproduces Range where
-    reproduce (Range (AlexPn _ lineX colX) (AlexPn _ lineY colY)) txt =
-        reproduceFromLineCol (lineX, colX) (lineY, colY) txt
+instance Semigroup Range where
+    Range a _ <> Range _ b = Range a b
+
+instance IsTrace Range where
+    trace txt (Range (AlexPn _ lineX colX) (AlexPn _ lineY colY)) =
+        reproduceFromLineCol txt (lineX, colX) (lineY, colY)
 
 -- | Performs the union of two ranges by creating a new range starting at the
 -- start position of the first range, and stopping at the stop position of the
 -- second range.
-instance Semigroup Range where
-    Range a _ <> Range _ b = Range a b
-
 data RangedToken = RangedToken
   { rtToken :: Token
   , rtRange :: Range

diff --git a/app/Output.hs b/app/Output.hs
@@ -13,8 +13,6 @@ import System.Console.ANSI
 import System.Directory.Tree
 import System.FilePath
 
-import Exp
-
 singleInd :: String
 singleInd = "   "