strings and a few other small nice changes

10 files changed, 200 insertions, 173 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index 8df703c..7996926 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -2,9 +2,10 @@ module Builtins where
 
 import Paths_prlg
 
-import Code (Builtin(..), Code, Datum(..), Instr(..), InterpFn)
+import Code (Builtin(..), Code, Datum(..), Id(..), Instr(..), InterpFn)
 import CodeLens
 import qualified Compiler as Co
+import Constant
 import Control.Exception (IOException, catch)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
@@ -16,7 +17,7 @@ import qualified Data.Map as M
 import Data.Maybe (fromJust)
 import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
 import Heap (Dereferenced(..), derefHeap, heapStruct, newHeapVars, writeHeap)
-import qualified IR
+import IR (PrlgInt(..), StrTable(..))
 import Interpreter (backtrack)
 import Lens.Micro.Mtl
 import Load (processInput)
@@ -29,10 +30,11 @@ continue = pure Nothing
 
 showTerm itos heap = runIdentity . heapStruct atom struct hrec heap
   where
-    atom (Atom a) = pure $ "'" ++ itos M.! a ++ "'"
-    atom (Number n) = pure (show n)
+    atom (C (Atom a)) = pure $ "'" ++ itos M.! a ++ "'"
+    atom (C (Number n)) = pure (show n)
+    atom (C (Str str)) = pure (show str)
     atom VoidRef = pure "_"
-    struct (Struct (IR.Id h _)) args =
+    struct (Struct (Id h _)) args =
       pure $ "'" ++ itos M.! h ++ "'(" ++ intercalate "," args ++ ")"
     hrec (HeapRef hr) ref =
       pure $
@@ -45,7 +47,7 @@ printLocals :: InterpFn
 printLocals = do
   scope <- use (cur . gvar)
   heap <- use (cur . heap)
-  IR.StrTable _ _ itos <- use strtable
+  StrTable _ _ itos <- use strtable
   flip traverse (M.assocs scope) $ \(local, ref) ->
     lift . outputStrLn $ "_Local" ++ show local ++ " = " ++
     showTerm itos heap ref
@@ -76,7 +78,7 @@ write' :: InterpFn -> InterpFn
 write' c =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- use strtable
+    StrTable _ _ itos <- use strtable
     lift . outputStr $ showTerm itos heap arg
     c --this now allows error fallthrough but we might like EitherT
 
@@ -90,7 +92,7 @@ nl = do
 writeln :: InterpFn
 writeln = write' nl
 
-assertFact :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
+assertFact :: (Code -> Id -> PrlgEnv ()) -> InterpFn
 assertFact addClause =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
@@ -101,7 +103,7 @@ assertFact addClause =
         continue
       _ -> prlgError "assert fact failure"
 
-assertRule :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
+assertRule :: (Code -> Id -> PrlgEnv ()) -> InterpFn
 assertRule addClause =
   withArgs [0, 1] $ \args -> do
     scope <- use (cur . hvar)
@@ -123,8 +125,8 @@ retractall =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
     case derefHeap heap arg of
-      BoundRef _ (Atom a) ->
-        dropProcedure (IR.Id {IR.arity = 0, IR.str = a}) >> continue
+      BoundRef _ (C (Atom a)) ->
+        dropProcedure (Id {arity = 0, str = a}) >> continue
       BoundRef _ (Struct id) -> dropProcedure id >> continue
       _ -> prlgError "retractall needs a struct"
 
@@ -153,7 +155,7 @@ exec = exec' (const [Done])
 stop :: InterpFn
 stop =
   withArgs [0] $ \[arg] -> do
-    IR.StrTable _ _ itos <- use strtable
+    StrTable _ _ itos <- use strtable
     heap <- use (cur . heap)
     prlgError $ "stop: " ++ showTerm itos heap arg
 
@@ -163,17 +165,17 @@ struct = do
   heap <- use (cur . heap)
   scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 0 of
-    Just (BoundRef addr (Struct IR.Id {IR.arity = arity, IR.str = str})) ->
+    Just (BoundRef addr (Struct Id {arity = arity, str = str})) ->
       structUnify arity str
     _ -> structAssemble
 
 heapListLength listAtom heap ref = go 0 ref ref (id, fromJust . step)
   where
     nil r
-      | BoundRef _ str <- derefHeap heap r = str == Atom listAtom
+      | BoundRef _ str <- derefHeap heap r = str == C (Atom listAtom)
       | otherwise = False
     step r
-      | BoundRef addr (Struct IR.Id {IR.arity = 2, IR.str = listAtom'}) <-
+      | BoundRef addr (Struct Id {arity = 2, str = listAtom'}) <-
          derefHeap heap r
       , listAtom == listAtom' = Just (addr + 2)
       | otherwise = Nothing
@@ -190,7 +192,7 @@ structAssemble = do
   heap <- use (cur . heap)
   scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 1 of
-    Just (BoundRef addr (Atom str)) -> do
+    Just (BoundRef addr (C (Atom str))) -> do
       listAtom <- findAtom "[]"
       case scope M.!? 2 >>= heapListLength listAtom heap of
         Just arity -> structUnify arity str
@@ -203,14 +205,13 @@ structUnify arity str = do
   listAtom <- findAtom "[]"
   pvars <- newHeapVars arity
   let hcode = map U $ maybe VoidRef HeapRef . (scope M.!?) <$> [0 .. 2]
-      structData =
-        Struct IR.Id {IR.arity = arity, IR.str = str} : map HeapRef pvars
+      structData = Struct Id {arity = arity, str = str} : map HeapRef pvars
       paramsData =
         concatMap
-          (\pv -> [Struct IR.Id {IR.arity = 2, IR.str = listAtom}, HeapRef pv])
+          (\pv -> [Struct Id {arity = 2, str = listAtom}, HeapRef pv])
           pvars ++
-        [Atom listAtom]
-      gcode = map U $ structData ++ [Atom str] ++ paramsData
+        [C $ Atom listAtom]
+      gcode = map U $ structData ++ [C $ Atom str] ++ paramsData
   zoom cur $ do
     gol %= (gcode ++)
     hed %= (hcode ++)
@@ -231,7 +232,16 @@ number = do
   heap <- use (cur . heap)
   scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 0 of
-    Just (BoundRef _ (Number _)) -> continue
+    Just (BoundRef _ (C (Number _))) -> continue
+    _ -> backtrack
+
+string :: InterpFn
+string = do
+  heap <- use (cur . heap)
+  scope <- use (cur . hvar)
+  --TODO unify with number/var/...
+  case derefHeap heap <$> scope M.!? 0 of
+    Just (BoundRef _ (C (Str _))) -> continue
     _ -> backtrack
 
 sameTerm :: InterpFn
@@ -260,9 +270,9 @@ op :: InterpFn
 op =
   withArgs [0, 1, 2] $ \args -> do
     heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- use strtable
+    StrTable _ _ itos <- use strtable
     case map (derefHeap heap) args of
-      [BoundRef _ (Number prio), BoundRef _ (Atom fixityAtom), BoundRef _ (Atom opatom)]
+      [BoundRef _ (C (Number prio)), BoundRef _ (C (Atom fixityAtom)), BoundRef _ (C (Atom opatom))]
         | Just op <-
            (,) <$> itos M.!? opatom <*>
            (O.Op prio <$> ((itos M.!? fixityAtom) >>= O.fixity)) -> do
@@ -274,9 +284,9 @@ deop :: InterpFn
 deop =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- use strtable
+    StrTable _ _ itos <- use strtable
     case derefHeap heap arg of
-      BoundRef _ (Atom opatom)
+      BoundRef _ (C (Atom opatom))
         | Just op <- itos M.!? opatom -> do
           ops %= filter ((/= op) . fst)
           continue
@@ -326,7 +336,8 @@ intBinary op =
   withArgs [0, 1] $ \[arg1, arg2] -> do
     heap <- use (cur . heap)
     case derefHeap heap <$> [arg1, arg2] of
-      [BoundRef _ (Number n1), BoundRef _ (Number n2)] -> putInt (op n1 n2) 2
+      [BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] ->
+        putInt (op n1 n2) 2
       _ -> prlgError "int binary needs numbers"
 
 intBinPred :: (Int -> Int -> Bool) -> InterpFn
@@ -334,7 +345,7 @@ intBinPred op =
   withArgs [0, 1] $ \args -> do
     heap <- use (cur . heap)
     case derefHeap heap <$> args of
-      [BoundRef _ (Number n1), BoundRef _ (Number n2)] ->
+      [BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] ->
         if op n1 n2
           then continue
           else backtrack
@@ -345,7 +356,7 @@ intUnary op =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
     case derefHeap heap arg of
-      BoundRef _ (Number n) -> putInt (op n) 1
+      BoundRef _ (C (Number n)) -> putInt (op n) 1
       _ -> prlgError "int unary needs number"
 
 intUnPred :: (Int -> Bool) -> InterpFn
@@ -353,7 +364,7 @@ intUnPred op =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
     case derefHeap heap arg of
-      BoundRef _ (Number n) ->
+      BoundRef _ (C (Number n)) ->
         if op n
           then continue
           else backtrack
@@ -366,28 +377,28 @@ putInt val sc = do
     Nothing -> continue
     Just a ->
       case derefHeap heap a of
-        BoundRef _ (Number val')
+        BoundRef _ (C (Number val'))
           | val == val' -> continue
-        FreeRef a' -> writeHeap a' (Number val) >> continue
+        FreeRef a' -> writeHeap a' (C (Number val)) >> continue
         _ -> backtrack
 
 {- adding the builtins -}
 addOp :: (String, O.Op) -> PrlgEnv ()
 addOp op = ops %= (op :)
 
-modDef :: ([Code] -> Maybe [Code]) -> IR.Id -> PrlgEnv ()
+modDef :: ([Code] -> Maybe [Code]) -> Id -> PrlgEnv ()
 modDef fn struct = defs %= M.alter (maybe (fn []) fn) struct
 
-addClauseA :: Code -> IR.Id -> PrlgEnv ()
+addClauseA :: Code -> Id -> PrlgEnv ()
 addClauseA code = modDef $ Just . (code :)
 
-addClauseZ :: Code -> IR.Id -> PrlgEnv ()
+addClauseZ :: Code -> Id -> PrlgEnv ()
 addClauseZ code = modDef $ Just . (++ [code])
 
-addProcedure :: [Code] -> IR.Id -> PrlgEnv ()
+addProcedure :: [Code] -> Id -> PrlgEnv ()
 addProcedure heads = modDef $ Just . const heads
 
-dropProcedure :: IR.Id -> PrlgEnv ()
+dropProcedure :: Id -> PrlgEnv ()
 dropProcedure = modDef $ const Nothing
 
 addProc :: [Code] -> String -> Int -> PrlgEnv ()
@@ -413,9 +424,9 @@ load :: Bool -> InterpFn
 load queryMode =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- use strtable --TODO the argument here should preferably be a string, right?
+    StrTable _ _ itos <- use strtable --TODO the argument here should preferably be a string, right?
     case derefHeap heap arg of
-      BoundRef _ (Atom a) -> do
+      BoundRef _ (C (Atom a)) -> do
         let fn = itos M.! a
         doLoad queryMode (itos M.! a)
       _ -> prlgError "load needs an atom"
@@ -425,7 +436,7 @@ addPrelude :: PrlgEnv ()
 addPrelude = do
   pure undefined
   {- absolute primitives -}
-  addBi (pure Nothing) "true" 0
+  addProc [[Done]] "true" 0
   addBi backtrack "fail" 0
   addBi stop "stop" 1
   addOp $ O.xfx "=" 700
@@ -456,6 +467,7 @@ addPrelude = do
   addBi struct "struct" 3
   addBi var "var" 1
   addBi number "number" 1
+  addBi string "string" 1
   addBi sameTerm "same_term" 2
   addBi currentPredicate "current_predicate" 1
   {- code loading -}
@@ -489,30 +501,30 @@ addPrelude = do
           ]
           ("expand_" ++ q)
           2
-  expandCode "load"
-  expandCode "query"
+   in do expandCode "load"
+         expandCode "query"
   {- int primops -}
   let add2IntOp nm op = addBi (intBinary op) ("int2_" ++ nm) 3
       add1IntOp nm op = addBi (intUnary op) ("int1_" ++ nm) 2
       add2IntPred nm op = addBi (intBinPred op) ("int2p_" ++ nm) 2
       add1IntPred nm op = addBi (intUnPred op) ("int1p_" ++ nm) 1
-  add2IntOp "add" (+)
-  add2IntOp "sub" (-)
-  add1IntOp "neg" negate
-  add1IntOp "abs" abs
-  add2IntOp "mul" (*)
-  add2IntOp "div" div
-  add2IntOp "mod" mod
-  add2IntOp "bitand" (.&.)
-  add2IntOp "bitor" (.|.)
-  add2IntOp "bitxor" xor
-  add2IntOp "shl" shiftL
-  add2IntOp "shr" shiftR
-  add1IntPred "zero" (== 0)
-  add2IntPred "eq" (==)
-  add2IntPred "lt" (<)
-  add2IntPred "leq" (<=)
-  add2IntPred "neq" (/=)
+   in do add2IntOp "add" (+)
+         add2IntOp "sub" (-)
+         add1IntOp "neg" negate
+         add1IntOp "abs" abs
+         add2IntOp "mul" (*)
+         add2IntOp "div" div
+         add2IntOp "mod" mod
+         add2IntOp "bitand" (.&.)
+         add2IntOp "bitor" (.|.)
+         add2IntOp "bitxor" xor
+         add2IntOp "shl" shiftL
+         add2IntOp "shr" shiftR
+         add1IntPred "zero" (== 0)
+         add2IntPred "eq" (==)
+         add2IntPred "lt" (<)
+         add2IntPred "leq" (<=)
+         add2IntPred "neq" (/=)
   {- query tools -}
   addBi printLocals "print_locals" 0
   addBi promptRetry' "prompt_retry" 0
diff --git a/app/Code.hs b/app/Code.hs
index b60ab66..6efa5b9 100644
--- a/app/Code.hs
+++ b/app/Code.hs
@@ -2,24 +2,31 @@
 
 module Code where
 
+import Constant
 import Control.Monad.Trans.State.Lazy (StateT)
 import qualified Data.Map as M
-import IR (Id(..), StrTable)
+import IR (StrTable)
 import Operators (Ops)
 import Parser (PAST)
 import System.Console.Haskeline (InputT)
 
+data Id =
+  Id
+    { str :: !Int
+    , arity :: !Int
+    }
+  deriving (Show, Eq, Ord)
+
 data Datum
-  = Atom Int -- unifies a symbolic constant
-  | Number Int -- unifies a numeric constant
-  | Struct Id -- unifies a structure with arity
+  = C !Constant -- unifies a constant
+  | Struct !Id -- unifies a structure with arity
   | VoidRef -- unifies with anything
-  | LocalRef Int -- code-local variable idx (should never occur on heap)
-  | HeapRef Int -- something further on the heap
+  | LocalRef !Int -- code-local variable idx (should never occur on heap)
+  | HeapRef !Int -- something further on the heap
   deriving (Show, Eq, Ord)
 
 data Instr
-  = U Datum -- unify/resolve something
+  = U !Datum -- unify/resolve something
   | Invoke Builtin -- give control to a builtin (invoked from head)
   | Done -- all done, can return
   | Cut -- remove choicepoints of the current goal
@@ -31,7 +38,7 @@ type Code = [Instr]
 type Defs = M.Map Id [Code]
 
 data Heap =
-  Heap Int (M.Map Int Datum)
+  Heap !Int (M.Map Int Datum)
   deriving (Show)
 
 emptyHeap = Heap 1 M.empty
diff --git a/app/Compiler.hs b/app/Compiler.hs
index f77a969..693bf99 100644
--- a/app/Compiler.hs
+++ b/app/Compiler.hs
@@ -1,20 +1,12 @@
 module Compiler where
 
+import Constant
 import Data.Char (isUpper)
 import qualified Data.Map as M
 
-import Code (Code, Datum(..), Heap, Instr(..))
+import Code (Code, Datum(..), Heap, Id(..), Instr(..))
 import Heap (heapStruct)
-import IR (Id(..), PrlgInt(..), StrTable(..))
-
-desugarPrlg :: Int -> PrlgInt -> PrlgInt
-desugarPrlg list = go
-  where
-    go (CallI id ps) = CallI id $ map go ps
-    go (ListI (x:xs) t) = CallI list [go x, go (ListI xs t)]
-    go (ListI [] Nothing) = AtomI list
-    go (ListI [] (Just x)) = go x
-    go x = x
+import IR (PrlgInt(..), StrTable(..))
 
 varname :: String -> Bool
 varname ('_':_) = True
@@ -23,24 +15,24 @@ varname _ = False
 
 varOccurs :: PrlgInt -> M.Map Int Int
 varOccurs (CallI _ xs) = M.unionsWith (+) $ map varOccurs xs
-varOccurs (VarI idx _) = M.singleton idx 1
+varOccurs (VarI idx) = M.singleton idx 1
 varOccurs _ = M.empty
 
 variablizePrlg :: Int -> StrTable -> PrlgInt -> PrlgInt
 variablizePrlg void (StrTable _ _ itos) = go
   where
     go (CallI i ps) = CallI i $ map go ps
-    go (AtomI i)
+    go o@(ConstI (Atom i))
       | i == void = VoidI
-      | varname (itos M.! i) = VarI i i
-      | otherwise = AtomI i
+      | varname (itos M.! i) = VarI i
+      | otherwise = o
     go x = x
 
 renumVars :: (Int -> Maybe PrlgInt) -> PrlgInt -> PrlgInt
 renumVars rename = go
   where
     go (CallI i ps) = CallI i $ map go ps
-    go (VarI idx i)
+    go (VarI idx)
       | Just new <- rename idx = new
     go x = x
 
@@ -50,7 +42,7 @@ squashVars x =
       m' =
         M.fromList $
         [(idx, VoidI) | (idx, n) <- occurs, n <= 1] ++
-        [(idx, VarI idx' 0) | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
+        [(idx, VarI idx') | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
    in renumVars (m' M.!?) x
 
 squashChoices :: [Code] -> Code
@@ -79,9 +71,8 @@ compileGoal = compileArg . struct2goal
 compileArg :: PrlgInt -> Code
 compileArg (CallI i args) =
   U (Struct Id {str = i, arity = length args}) : concatMap compileArg args
-compileArg (AtomI s) = [U (Atom s)]
-compileArg (NumI s) = [U (Number s)]
-compileArg (VarI x _) = [U (LocalRef x)]
+compileArg (ConstI c) = [U (C c)]
+compileArg (VarI x) = [U (LocalRef x)]
 compileArg (VoidI) = [U VoidRef]
 
 seqGoals :: [Code] -> Code
@@ -90,20 +81,19 @@ seqGoals = (++ [Done]) . concat
 heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt
 heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref
   where
-    atom (Atom s) = pure $ AtomI s
-    atom (Number n) = pure $ NumI n
+    atom (C c) = pure (ConstI c)
     atom VoidRef = pure $ VoidI
     struct (Struct s) args = pure $ CallI (str s) args
     hrec (HeapRef r) ref
-      | r == ref = pure $ VarI r 0
+      | r == ref = pure $ VarI r
       | otherwise = heaperr
 
 -- TODO check if this is used
 goal2struct :: PrlgInt -> PrlgInt
-goal2struct (CallI s []) = AtomI s
+goal2struct (CallI s []) = ConstI (Atom s)
 goal2struct x = x
 
 struct2goal :: PrlgInt -> PrlgInt
-struct2goal (AtomI s) = CallI s []
+struct2goal (ConstI (Atom s)) = CallI s []
 struct2goal call@(CallI _ _) = call
 struct2goal _ = error "TODO."
diff --git a/app/Env.hs b/app/Env.hs
index 03a7ce8..0b648f8 100644
--- a/app/Env.hs
+++ b/app/Env.hs
@@ -1,23 +1,23 @@
 module Env where
 
-import Code (InterpFn, PrlgEnv)
+import Code (Id(..), InterpFn, PrlgEnv)
 import CodeLens
-import qualified IR
+import IR (StrTable, strtablize)
 import Lens.Micro.Mtl
 
-withStrTable :: (IR.StrTable -> (IR.StrTable, a)) -> Env.PrlgEnv a
+withStrTable :: (StrTable -> (StrTable, a)) -> Env.PrlgEnv a
 withStrTable f = do
   (st', x) <- f <$> use strtable
   strtable .= st'
   return x
 
-findStruct :: String -> Int -> Env.PrlgEnv IR.Id
+findStruct :: String -> Int -> Env.PrlgEnv Id
 findStruct str arity = do
   stri <- findAtom str
-  return IR.Id {IR.str = stri, IR.arity = arity}
+  return Id {str = stri, arity = arity}
 
 findAtom :: String -> Env.PrlgEnv Int
-findAtom = withStrTable . flip IR.strtablize
+findAtom = withStrTable . flip strtablize
 
 type PrlgEnv a = Code.PrlgEnv a
 
diff --git a/app/Heap.hs b/app/Heap.hs
index 1daa52f..99135a2 100644
--- a/app/Heap.hs
+++ b/app/Heap.hs
@@ -4,7 +4,6 @@ import Code
 import CodeLens
 import Data.Foldable (traverse_)
 import qualified Data.Map as M
-import IR (Id(..))
 import Lens.Micro.Mtl
 
 data Dereferenced
diff --git a/app/IR.hs b/app/IR.hs
index fef193b..d7345e5 100644
--- a/app/IR.hs
+++ b/app/IR.hs
@@ -1,28 +1,15 @@
 module IR where
 
+import Constant
 import Data.Char (isNumber)
 import Data.List (mapAccumL)
 import qualified Data.Map as M
-
-data PrlgStr
-  = CallS String [PrlgStr]
-  | LiteralS String
-  | ListS [PrlgStr] (Maybe PrlgStr)
-  deriving (Show)
-
-data Id =
-  Id
-    { str :: Int
-    , arity :: Int
-    }
-  deriving (Show, Eq, Ord)
+import Parser (Lexeme(..), PrlgStr(..))
 
 data PrlgInt
   = CallI Int [PrlgInt]
-  | AtomI Int
-  | NumI Int
-  | ListI [PrlgInt] (Maybe PrlgInt) -- only exists before desugaring
-  | VarI Int Int -- VarI localIndex strTableString
+  | ConstI Constant
+  | VarI Int -- VarI localIndex strTableString
   | VoidI
   deriving (Show)
 
@@ -37,16 +24,16 @@ strtablize t@(StrTable nxt fwd rev) str =
     Just i -> (t, i)
     _ -> (StrTable (nxt + 1) (M.insert str nxt fwd) (M.insert nxt str rev), nxt)
 
+internLexeme t (Tok str)
+  | all isNumber str = (t, ConstI . Number $ read str)
+  | otherwise = ConstI . Atom <$> strtablize t str
+internLexeme t (QTok str _) = ConstI . Atom <$> strtablize t str
+internLexeme t (DQTok str _) = (t, ConstI $ Str str)
+
 internPrlg :: StrTable -> PrlgStr -> (StrTable, PrlgInt)
 internPrlg = go
   where
-    go t (LiteralS str)
-      | all isNumber str = (t, NumI $ read str)
-      | otherwise = AtomI <$> strtablize t str
+    go t (LiteralS lex) = internLexeme t lex
     go t (CallS str ps) =
       let (t', i) = strtablize t str
        in CallI i <$> mapAccumL go t' ps
-    go t (ListS elems Nothing) = flip ListI Nothing <$> mapAccumL go t elems
-    go t (ListS elems (Just tail)) =
-      let (t', tail') = go t tail
-       in flip ListI (Just tail') <$> mapAccumL go t' elems
diff --git a/app/Interpreter.hs b/app/Interpreter.hs
index 2ad0118..440b6fa 100644
--- a/app/Interpreter.hs
+++ b/app/Interpreter.hs
@@ -8,6 +8,7 @@ import Code
   , Cho(..)
   , Code
   , Datum(..)
+  , Id(..)
   , Instr(..)
   , InterpFn
   , emptyHeap
@@ -18,7 +19,7 @@ import Control.Monad (when)
 import qualified Data.Map as M
 import Env (PrlgEnv)
 import Heap
-import IR (Id(..), StrTable(..))
+import IR (StrTable(..))
 import Lens.Micro
 import Lens.Micro.Mtl
 
@@ -145,7 +146,7 @@ cutHead = do
 
 cutGoal = doCut >> advance
 
-openGoal :: IR.Id -> InterpFn
+openGoal :: Id -> InterpFn
 openGoal fn = do
   def <- (M.!? fn) <$> use defs
   case def of
@@ -244,13 +245,10 @@ uOK = uNext >> continue
 
 unify :: Datum -> Datum -> InterpFn
 unify VoidRef VoidRef = uOK
-unify (Atom _) VoidRef = uOK
-unify VoidRef (Atom _) = uOK
-unify (Atom a) (Atom b)
+unify (C _) VoidRef = uOK
+unify VoidRef (C _) = uOK
+unify (C a) (C b)
   | a == b = uOK
-unify (Number _) VoidRef = uOK
-unify VoidRef (Number _) = uOK
-unify (Number a) (Number b)
   | a == b = uOK
 unify (Struct a) VoidRef = do
   uNext
diff --git a/app/Load.hs b/app/Load.hs
index 9fb4c94..5a482fd 100644
--- a/app/Load.hs
+++ b/app/Load.hs
@@ -1,6 +1,6 @@
 module Load where
 
-import Code (Code, PrlgEnv)
+import Code (Code, Id(..), PrlgEnv)
 import CodeLens
 import qualified Compiler as C
 import Control.Monad.Trans.Class (lift)
@@ -21,20 +21,19 @@ tokenize fn = left MP.errorBundlePretty . MP.parse P.lexPrlg fn
 parse :: String -> [P.Lexeme] -> Either String [P.PAST]
 parse fn = left MP.errorBundlePretty . MP.parse P.parsePrlg fn
 
-shunt :: P.PAST -> ExceptT String PrlgEnv IR.PrlgStr
+shunt :: P.PAST -> ExceptT String PrlgEnv P.PrlgStr
 shunt past = do
   ops <- lift $ use ops
   except . left (\err -> "operator resolution: " ++ err ++ "\n") $
     P.shuntPrlg ops past
 
-intern :: IR.PrlgStr -> PrlgEnv IR.PrlgInt
+intern :: P.PrlgStr -> PrlgEnv IR.PrlgInt
 intern prlgs = do
   prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs
   underscore <- findAtom "_"
   list <- findAtom "[]"
   withStrTable $ \st ->
-    ( st
-    , C.squashVars $ C.variablizePrlg underscore st $ C.desugarPrlg list prlgi)
+    (st, C.squashVars $ C.variablizePrlg underscore st prlgi)
 
 compile :: IR.PrlgInt -> PrlgEnv Code
 compile prlgv = do
@@ -58,9 +57,7 @@ expansion noexpand expander output x = do
     if expand
       then IR.CallI
              comma
-             [ IR.CallI (IR.str es) [x, IR.VarI (-1) 0]
-             , IR.CallI o [IR.VarI (-1) 0]
-             ]
+             [IR.CallI (str es) [x, IR.VarI (-1)], IR.CallI o [IR.VarI (-1)]]
       else noexpand o x
 
 queryExpansion = expansion (\_ -> id) "expand_query" "call"
diff --git a/app/Parser.hs b/app/Parser.hs
index e6b7a7a..9d11cc8 100644
--- a/app/Parser.hs
+++ b/app/Parser.hs
@@ -5,7 +5,8 @@ module Parser
   , parsePrlg
   , shuntPrlg
   , PAST
-  , Lexeme
+  , Lexeme(..)
+  , PrlgStr(..)
   ) where
 
 import Control.Monad (void)
@@ -42,14 +43,13 @@ import Text.Megaparsec
   )
 import Text.Megaparsec.Char (string)
 
-import IR (PrlgStr(..))
 import Operators (ArgKind(..), Fixity(..), Op(..), Ops)
 
 singleToks = ",;|()[]{}!"
 
 identParts = "_"
 
-notOpToks = "\'" ++ identParts
+notOpToks = "'\"" ++ identParts
 
 isOperatorlike x =
   (isSymbol x || isPunctuation x) && not (x `elem` singleToks ++ notOpToks)
@@ -64,6 +64,7 @@ data Lexeme
   = Blank String
   | Tok String
   | QTok String String -- unquoted quoted
+  | DQTok String String -- unquoted quoted
   deriving (Show, Eq, Ord)
 
 blank :: Lexer Lexeme
@@ -86,14 +87,15 @@ qtok = do
   z <- string "'"
   return $ QTok y (x ++ y ++ z)
 
-cmt :: Lexer Lexeme
-cmt =
-  Blank . concat <$>
-  sequence
-    [string "%", many $ satisfy (/= '\n'), choice [string "\n", "" <$ eof]]
+dqtok :: Lexer Lexeme
+dqtok = do
+  x <- string "\""
+  y <- many $ satisfy (/= '\"') -- TODO actual escaping
+  z <- string "\""
+  return $ DQTok y (x ++ y ++ z)
 
 lexeme :: Lexer Lexeme
-lexeme = choice [blank, tok, qtok, cmt]
+lexeme = choice [blank, tok, qtok, dqtok]
 
 lexPrlg :: Lexer [Lexeme]
 lexPrlg = many lexeme <* (many blank >> eof)
@@ -101,6 +103,7 @@ lexPrlg = many lexeme <* (many blank >> eof)
 showTok (Blank x) = x
 showTok (Tok x) = x
 showTok (QTok _ x) = x
+showTok (DQTok _ x) = x
 
 instance VisualStream [Lexeme] where
   showTokens _ (a :| b) = concatMap showTok (a : b)
@@ -146,9 +149,9 @@ instance TraversableStream [Lexeme] where
 
 data PAST
   = Call String [[PAST]]
-  | Seq [PAST]
+  | Group [PAST]
   | List [[PAST]] (Maybe [PAST])
-  | Literal String
+  | Literal Lexeme
   deriving (Show, Eq)
 
 type Parser = Parsec Void [Lexeme]
@@ -165,6 +168,7 @@ isNormalTokStr = (`notElem` [".", "[", "]", "(", "|", ")", "{", "}"])
 isNormalTok :: Lexeme -> Bool
 isNormalTok (Tok x) = isNormalTokStr x
 isNormalTok (QTok _ _) = True
+isNormalTok (DQTok _ _) = True
 isNormalTok _ = False
 
 isCallTok :: Lexeme -> Bool
@@ -174,34 +178,35 @@ isCallTok _ = True
 
 unTok (Tok t) = t
 unTok (QTok t _) = t
+unTok (DQTok t _) = t
 
 literal :: Parser PAST
 literal =
-  Literal . unTok <$>
+  Literal <$>
   free
     (choice
        [ satisfy isCallTok <* notFollowedBy (choice [lParen, lBrace])
        , satisfy (\x -> not (isCallTok x) && isNormalTok x)
        ])
 
-makeParams (Seq inner) = splitOn [Literal ","] inner
+makeParams (Group inner) = splitOn [Literal (Tok ",")] inner
 
 call eb contents fmod = do
   fn <- fmod . unTok <$> satisfy isCallTok -- not free
   (Call fn [] <$ try eb) <|> (Call fn . makeParams <$> free contents)
 
-parens = Seq <$> (free lParen *> some seqItem <* free rParen)
+parens = Group <$> (free lParen *> some seqItem <* free rParen)
 
-braces = Seq <$> (free lBrace *> some seqItem <* free rBrace)
+braces = Group <$> (free lBrace *> some seqItem <* free rBrace)
 
-emptyParens = Literal "()" <$ (free lParen >> free rParen)
+emptyParens = Literal (QTok "()" "()") <$ (free lParen >> free rParen)
 
-emptyBraces = Literal "{}" <$ (free lBrace >> free rBrace)
+emptyBraces = Literal (QTok "{}" "{}") <$ (free lBrace >> free rBrace)
 
 list = do
   free lBracket
   (List [] Nothing <$ free rBracket) <|> do
-    items <- splitOn [Literal ","] <$> some seqItem
+    items <- splitOn [Literal (Tok ",")] <$> some seqItem
     (List items Nothing <$ free rBracket) <|>
       (List items . Just <$> (free listTail *> some seqItem <* free rBracket))
 
@@ -237,7 +242,7 @@ lBrace = simpleTok "{"
 rBrace = simpleTok "}"
 
 clause :: Parser PAST
-clause = Seq <$> some (free seqItem) <* free period
+clause = Group <$> some (free seqItem) <* free period
 
 parsePrlg :: Parser [PAST]
 parsePrlg = ws *> many clause <* eof
@@ -246,6 +251,11 @@ type ShuntError = String
 
 type ShuntResult = Either ShuntError PrlgStr
 
+data PrlgStr
+  = CallS String [PrlgStr]
+  | LiteralS Lexeme
+  deriving (Show)
+
 err :: ShuntError -> Either ShuntError a
 err = Left
 
@@ -254,8 +264,10 @@ shuntPrlg ot = shuntPrlg' (("", Op 0 $ Infix Y X) : ot)
 
 shuntPrlg' :: Ops -> PAST -> ShuntResult
 shuntPrlg' ot (List hs t) =
-  ListS <$> traverse (shunt ot) hs <*> traverse (shunt ot) t
-shuntPrlg' ot (Seq ss) = shunt ot ss
+  foldr (\x y -> CallS "[]" [x, y]) <$>
+  (maybe (LiteralS $ Tok "[]") id <$> traverse (shunt ot) t) <*>
+  traverse (shunt ot) hs
+shuntPrlg' ot (Group ss) = shunt ot ss
 shuntPrlg' ot (Literal s) = pure (LiteralS s)
 shuntPrlg' ot (Call fn ss) = CallS fn <$> traverse (shunt ot) ss
 
@@ -296,13 +308,13 @@ shunt optable = start
              (ops', vs') <- pushInfix ops vs x
              wo ops' vs' xs
         , do getOperand x
-             ho ops vs (Literal "" : xs') -- app (see below)
+             ho ops vs (Literal (Tok "") : xs') -- app (see below)
         , do getPrefix x
-             ho ops vs (Literal "" : xs') -- also app!
+             ho ops vs (Literal (Tok "") : xs') -- also app!
         , err "expected infix or suffix operator"
         ]
     {- incoming non-literal operand; there must be an app in between -}
-    ho ops vs xs@(_:_) = ho ops vs (Literal "" : xs)
+    ho ops vs xs@(_:_) = ho ops vs (Literal (Tok "") : xs)
     {- the last operand was last, pop until finished -}
     ho [] [res] [] = pure res
     ho ops vs [] = do
@@ -319,11 +331,14 @@ shunt optable = start
     {- Operator checks -}
     uniq [x] = pure x
     uniq _ = err "ambiguous operator"
-    getPrefix x = uniq [op | (s, op@(Op _ (Prefix _))) <- optable, s == x]
-    getSuffix x = uniq [op | (s, op@(Op _ (Suffix _))) <- optable, s == x]
-    getInfix x = uniq [op | (s, op@(Op _ (Infix _ _))) <- optable, s == x]
-    getOperand x
-      | null [op | (s, op) <- optable, s == x] = pure ()
+    getPrefix t =
+      uniq [op | Tok x <- [t], (s, op@(Op _ (Prefix _))) <- optable, s == x]
+    getSuffix t =
+      uniq [op | Tok x <- [t], (s, op@(Op _ (Suffix _))) <- optable, s == x]
+    getInfix t =
+      uniq [op | Tok x <- [t], (s, op@(Op _ (Infix _ _))) <- optable, s == x]
+    getOperand t
+      | null [op | Tok x <- [t], (s, op) <- optable, s == x] = pure ()
       | otherwise = err "expected an operand"
     {- actual pushery -}
     canPush :: Ops -> Op -> Either ShuntError Bool
@@ -371,7 +386,7 @@ shunt optable = start
     shunt1 ops vs x op = do
       cp <- canPush ops op
       if cp
-        then pure ((x, op) : ops, vs)
+        then pure ((unTok x, op) : ops, vs)
         else do
           (ops', vs') <- pop ops vs
           shunt1 ops' vs' x op --prefix would behave differently here but that's impossible by canPush
diff --git a/prlg.cabal b/prlg.cabal
index 693ade9..92001b2 100644
--- a/prlg.cabal
+++ b/prlg.cabal
@@ -21,18 +21,40 @@ maintainer:         exa.exa@gmail.com
 -- category:
 extra-source-files: CHANGELOG.md
 
-data-dir:       inst
-data-files:     *.pl
+data-dir:           inst
+data-files:         *.pl
 
 executable prlg
     main-is:          Main.hs
 
     -- Modules included in this executable, other than Main.
-    other-modules:    Interpreter, Compiler, Parser, Frontend, IR, Operators, Code, Builtins, Env, Load, CodeLens, Heap, Paths_prlg
+    other-modules:    Paths_prlg,
+                      Builtins,
+                      Code,
+                      CodeLens,
+                      Compiler,
+                      Constant,
+                      Env,
+                      Frontend,
+                      Heap,
+                      Interpreter,
+                      IR,
+                      Load,
+                      Operators,
+                      Parser
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
-    build-depends:    base >=4.14, containers, megaparsec, haskeline, split, transformers, microlens, microlens-th, microlens-mtl
+    build-depends:    base >=4.14,
+                      containers,
+                      haskeline,
+                      megaparsec,
+                      microlens,
+                      microlens-mtl,
+                      microlens-th,
+                      split,
+                      transformers
+
     hs-source-dirs:   app
     default-language: Haskell2010
     ghc-options:      -Wunused-imports